home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / gjr / cmplrtst.lha / sort / fxhsort.scm next >
Encoding:
Text File  |  1990-03-27  |  2.3 KB  |  103 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. #|
  4. Description:
  5.  
  6. Heap sort using fixnums as vector indeces.
  7.  
  8. Usage:
  9.  
  10. (sort '(10 9 8 7 6 5 4 3 2 1) <) -> (1 2 3 4 5 6 7 8 9 10)
  11. (sort '#(10 9 8 7 6 5 4 3 2 1) <) -> #(1 2 3 4 5 6 7 8 9 10)
  12. (define foo '#(10 9 8 7 6 5 4 3 2 1))
  13. (sort! foo <)
  14. foo -> #(1 2 3 4 5 6 7 8 9 10)
  15.  
  16. |#
  17.  
  18. (declare (usual-integrations 1+ -1+ + = < > integer-divide)
  19.      (integrate-primitive-procedures
  20.       (-1+ minus-one-plus-fixnum)
  21.       (1+ one-plus-fixnum)
  22.       (+ plus-fixnum)
  23.       (= equal-fixnum?)
  24.       (< less-than-fixnum?)
  25.       (> greater-than-fixnum?)
  26.       (integer-divide divide-fixnum)))
  27.  
  28. (let-syntax ((define-integrable
  29.            (macro (params . body)
  30.          `(begin
  31.             (declare (integrate-operator ,(car params)))
  32.             (define ,(car params)
  33.               (named-lambda ,params
  34.             (declare (integrate ,@(cdr params)))
  35.             ,@body))))))
  36.  
  37. (define (sort obj pred)
  38.   (cond ((pair? obj)
  39.      (vector->list (sort! (list->vector obj) pred)))
  40.     ((vector? obj)
  41.      (sort! (vector-copy obj) pred))
  42.     ((null? obj)
  43.      '())
  44.     (else
  45.      (error "sort: argument should be a list or a vector"))))
  46.  
  47. (define (sort! vec pred)
  48.   (define-integrable (quo x y)
  49.     (car (integer-divide x y)))  
  50.  
  51.   (define-integrable (exchange! i j)
  52.     (let ((old (vector-ref vec i)))
  53.       (vector-set! vec i (vector-ref vec j))
  54.       (vector-set! vec j old)))
  55.  
  56.   (define (heapify-up n)
  57.     (let ((next (quo (-1+ n) 2)))
  58.       (if (and (not (zero? n))
  59.            (not (pred (vector-ref vec n)
  60.               (vector-ref vec next))))
  61.       (begin
  62.         (exchange! n next)
  63.         (heapify-up next)))))
  64.         
  65.   (define (heapify-down n max)
  66.     (define-integrable (check m)
  67.       (if (pred (vector-ref vec n)
  68.         (vector-ref vec m))
  69.       (begin
  70.         (exchange! n m)
  71.         (heapify-down m max))))
  72.  
  73.     (let* ((p (+ n (1+ n)))
  74.        (q (1+ p)))
  75.       (if (and (not (> q max))
  76.            (not (pred (vector-ref vec q)
  77.               (vector-ref vec p))))
  78.       (check q)
  79.       (if (not (> p max))
  80.           (check p)))))
  81.  
  82.   (if (not (vector? vec))
  83.       (error "sort!: argument must be a vector" vec))
  84.  
  85.   (let ((max (-1+ (vector-length vec))))
  86.  
  87.     (define (heapify-loop n)
  88.       (if (not (> n max))
  89.       (begin
  90.         (heapify-up n)
  91.         (heapify-loop (1+ n)))))
  92.       
  93.     (define (sort-loop dest)
  94.       (if (> dest 0)
  95.       (begin
  96.         (exchange! dest 0)
  97.         (heapify-down 0 (-1+ dest))
  98.         (sort-loop (-1+ dest)))))
  99.  
  100.     (heapify-loop 0)
  101.     (sort-loop max)
  102.     vec))
  103. ) ;; End of let-syntax